COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002
C00021 ENDMK
C⊗;





; page display ;

(PPIOT 0 1) ; page 1 ;
(PPIOT 2 10) ; en position standard  ;
(PPIOT 3  (+ (* 15 \1000) 1))) ; 15 glitches de 1 ;

; page LISP ;
(PPIOT 0 \400002) ; page 2 ;
; la position est standard ;
(PPIOT 3 (+ (* 6 \1000) 1))) ; 6 glitches de 1 ;

(PPIOT 1 \300000) ; active la page 1 et 2 ;

(STATUS 2 0 2) ; ne pas imprimer le temps et la forme ;

(DE TTYS (X Y S)
	; edite la chaine S nornalement ;
	; en position : Xieme ligne Yieme colonne ;
	(UPGIOT ()
	 (cons \177 (cons \14 (cons (logxor \140 y)
		(cons (logxor \140 x) 
		   (MAPCAR (MAKLIST S) 'CASCII)))))))))))))

(de ttb (x y s) (ttys x y s))


;  Qu 'est ce que le robot ? C'est
   - sa position en x et y : xrpos et yrpos
   - s'il tient une boite ou pas :
			withnbox = nil
			ou
			withnbox = no de boite
;

; ROBOT trace un robot visible (i.e. visible = T)
  		    ou invisible (i.e. visible = NIL)
  si withnbox non-NIL (i.e. s'il tient une boite, elle
  est tracee ou effacee selon la visibilite du robot
;

(de robot (x y visible visiblebase)
  (ttb x (1- y) (if visible "|||" "   "))
  (ttb (1+ x) (1- y) (if visible "< >" "   "))
  (if withnbox (box (+ x 2) y withnbox visible visiblebase))
  )

(de box (x y n visible savebase)
  (setq y (- y 2))
  (ttb x y (if visible "-----" "     "))
  (ttb (+ x 1) y (if visible "|   |" "     "))
  (ttb (+ x 2) y (if (or visible savebase) "-----" "     "))
  (ttb (+ x 1) (+ y 2) (if visible n " "))
  )

; ROBOT peut se deplacer HORIZONTALEMENT par
			 (yrmov newy)
		     ou  VERTICALEMENT par
			 (xrmov newx)
 la vitesse de deplacement est reglee par la valeur
 de la variable globale RATE.
 Apres deplacement on a xrpos = newx, ou yrpos = newy, selon le cas.
;

(de yrmov (to ;; dir)
  (setq dir (if (gt (- to yrpos) 0) 1 -1))
  (while (neq to yrpos)
         (robot xrpos yrpos nil) ; invisibler !! ;
         (beep) (repeat rate)    ; temporiser    ;
         (robot xrpos (setq yrpos (+ dir yrpos)) t)
				 ; visibler la new pos ;
  ))

(de xrmov (to ;; dir)
  (setq dir (if (gt (- to xrpos) 0) 1 -1))
  ; horrible hack pour bases ;
  (if (or (neq dir -1) (null withnbox)) nil
      (robot xrpos yrpos nil t)
      (beep) (repeat rate)
      (robot (decr xrpos) yrpos t))
  ; end of horrible hack ;
  (while (neq to xrpos)
         (robot xrpos yrpos nil)
         (beep) (repeat rate)
         (robot (setq xrpos (+ dir xrpos)) yrpos t)
  ))

; Ou vit le robot AZERTYOP ? Dans un pays tel que ya
  un PLAFOND : ligne X = 10
  reglable quand meme (>= 10) : valeur de la variable globale PLAFOND

  un sol XTERRE ou sont poses les blocs, par defaut ligne X = 23
  Initialement le robot est quelque part.
  La fonction PARTERRE initialise tout ca.
;
(de parterre (xtr plaf initxrob inityrob)
  (setq xterre xtr plafond plaf xrpos initxrob yrpos inityrob)
  (setq withnbox nil) ; au depart il tient rien ! ;
  (setq boxes nil)    ; au depart ya pas de boites ! ;
  (setq rate 0)       ; controle vitesse de deplacement ;
  (ttb xterre 0 (dupl "-" 80)) ; hack CHAILLOUX pour tracer le sol ;
  (robot xrpos yrpos t)
  (initplaces)        ; initialisation des places libres ;
  )


(de initplaces ()
  (setq places (append nplaces nil))
  )

;  Les places libres initiales sont dans la liste globale NPLACES
   recopiee dans la liste de travail (queue) PLACES
   PLACES est modifiee par (findplaceterre) et (giveplaceterre n)
;

(de findplaceterre () (nextl places))
(de giveplaceterre (n) (setq places (nconc1 places n)))

(setqq nplaces (3 9 17 27 37 49 61 68 75 ))  

; L'appel initial : ;

(parterre 23 10 10 40)

;  POUR: faire naitre une boite n sur
  					le sol: TERRE
					une boite de no: ON
   utiliser: (makenewbox n ON)
;

(de makenewbox (n on ;; aux x y)
  (if (eq on 'terre) (setq x xterre y (findplaceterre))
		     (setq aux (wherebox on) x (car aux) y (cadr aux)))
  (setq x (- x 2))
  (box x y n t)
  (inboxplace n x y)
  )

;  POUR: que le robot aille prendre la boite n
   utiliser: (gotakebox n)
;

(de gotakebox (n ;; aux x y)
  (setq aux (wherebox n) x (car aux) y (cadr aux))
  (yrmov y)		; deplacement horizontal ;
  (xrmov (- x 2))	; descendre prendre boite ;
  (setq withnbox n)	; robot tient a present quelque chose ;
  (xrmov plafond)	; le baron noir remonte avec sa proie ;
  (if (= x (- xterre 2)) (giveplaceterre y))
			; remise a jour des places libres si
			  la boite prise etait par terre      ;
  (outboxplace n x y)	; remise a jour de la data-base des
			  boites-et-leurs-coordonnees-x-y     ;
  )

;  POUR: que le robot aille poser la boite qu'il tient
	 (c'est la valeur de withnbox) sur l'objet ON i.e.
							TERRE
							ou
							boite n
   utiliser (goputbox ON)
;

(de goputbox (on ;; aux x y)
  (if (eq on 'terre) (setq x xterre y (findplaceterre))
		     (setq aux (wherebox on) x (car aux) y (cadr aux)))
  (yrmov y)		; deplacement horizontal ;
  (xrmov (- x 4))	; descendre avec le bebe ;
  (inboxplace withnbox (- x 2) y)
			; remise a jour de la data-base  BOXES ;
  (setq withnbox nil)	; il ne tient plus rien  ;
  (xrmov plafond)	; il remonte au plafond  ;
  )



;  La data-base de (no-de-boite coord-x coord-y) est dans BOXES
   (wherebox n) -> (coord-x coord-y)
   (inboxplace n x y) -> colle le 3-uple dans BOXES
   (outboxplace n x y) -> delete le 3-uple out of BOXES
;

(de wherebox (n) (cassq n boxes))
(de inboxplace (n x y) (setq boxes (cons [n x y] boxes)))
(de outboxplace (n x y) (setq boxes (delete [n x y] boxes)))


(DE AZERTYOP (;; PHRASE)
  (PRINT '(AZERTYOP : BJOUR MSIEU))
  (SETQ WORD NIL DABA [['DABA]] FOCUS NIL #OBJ NIL #REL NIL #LOC NIL)
  (AZERCONT))

(DE AZERCONT ()
  (WHILE (NOT (EQUAL (SETQ PHRASE (READ)) '(BYE)))
         (OR (EVAL-NET (GET 'PHRASE 'NET) PHRASE)
             (PRINT '(AZERTYOP : ZAI RIEN COMPRIS MSIEU))))
  '(AZERTYOP : RVOIR MSIEU))

(DE EVAL-NET (NET PHRASE) (COND
  ((NULL NET) NIL)
  ((EVAL-CLAUSE (CAR NET) PHRASE))
  (T (EVAL-NET (CDR NET) PHRASE))))

(DE EVAL-CLAUSE (CLAUSE PHRASE)
  (IF (NULL CLAUSE) (LIST PHRASE)
      (SETQ LASTWORD WORD WORD (CAR PHRASE))
      (IF (ATOM (CAR CLAUSE))
          (IF (EQ (NEXTL CLAUSE) WORD)
              (EVAL-CLAUSE CLAUSE (CDR PHRASE)))
          (SELECTQ (CAAR CLAUSE)
            ($ACT (EPROGN (CDAR CLAUSE)) (EVAL-CLAUSE (CDR CLAUSE) PHRASE))
            ($OR (IF (MEMQ WORD (CDAR CLAUSE))
                     (EVAL-CLAUSE (CDR CLAUSE) (CDR PHRASE))))
            ($TEST (IF (EVAL (CADAR CLAUSE))
                       (EVAL-CLAUSE (CDR CLAUSE) (CDR PHRASE))))
	    ($CALL (SETQ AUX (EVAL-NET (GET (CADAR CLAUSE) 'NET) PHRASE))
   	           (IF AUX (EVAL-CLAUSE (CDR CLAUSE) (CAR AUX))))
            ()
  ))))))))))))))))))

(DF DEF-NET (L) (PUT (CAR L) (CDR L) 'NET))

(DEF-NET PHRASE
 (VOYONS ($ACT (SCENE)))
 (($CALL NG) ($ACT (SETQ #OBJ #NG))
  EST ($CALL LIEU) ($ACT (DECLARATIVE)))
 (PREND ($CALL NG-LE) ($ACT (SETQ #OBJ #NG) (IMPER-1)))
 (($OR MET POSE) ($CALL NG-LE) ($ACT (SETQ #OBJ #NG))
  ($CALL LIEU) ($ACT (IMPER-2)))
 (POSE ($CALL NG-LE) ($ACT (SETQ #OBJ #NG #LOC 'TERRE) (IMPER-2)))
 (OU EST ($CALL NG-IL) ($ACT (SETQ #OBJ #NG)(WHERE-Q)))
 (($OR DE DU) ($CALL NG) ($ACT (FOCUS-IT #NG) (P-OUI-MSIEUR)))
 (REPETE ($TEST (NUMBP (SETQ AUX WORD))) FOIS
  ($ACT (REPEAT AUX
		(MAPC PHRASE
		     '(LAMBDA (PHRASE) (EVAL-NET (GET 'PHRASE 'NET)
						PHRASE)))))
  ($ACT (P-OUI-MSIEU)))
 )

(DEF-NET NG
 (($TEST (NUMBP WORD)) ($ACT (SETQ #NG LASTWORD)))
 (LE CUBE ($TEST (NUMBP WORD)) ($ACT (SETQ #NG LASTWORD)))
 )

(DEF-NET LIEU
 (($OR PAR SUR) TERRE ($ACT (SETQ #LOC 'TERRE #REL 'SUR)))
 (SUR ($ACT (SETQ #REL 'SUR)) ($CALL NG-LUI) ($ACT (SETQ #LOC #NG)))
 (SOUS ($ACT (SETQ #REL 'SOUS)) ($CALL NG-LUI) ($ACT (SETQ #LOC #NG)))
 )

(DEF-NET NG-LE
  (($CALL NG))
  (LE ($ACT (SOLVE)))
  )

(DEF-NET NG-IL
  (($CALL NG))
  (IL ($ACT (SOLVE)))
  )

(DEF-NET NG-LUI
  (($CALL NG))
  (LUI ($ACT (SOLVE)))
  )

(DE PRESENT (-P- DABA) (COND
  ((NULL DABA) NIL)
  ((MATCH -P- (NEXTL DABA)))
  (T (PRESENT -P- DABA))))

(DE MATCH (-P- -D-) (COND
  ((AND (NULL -P-) (NULL -D-)) T)
  ((OR (NULL -P-) (NULL -D-)) NIL)
  ((ATOM (CAR -P-)) (IF (EQ (NEXTL -P-) (NEXTL -D-))
                        (MATCH -P- -D-)))
  ((EQ (CAAR -P-) '/,)
   (MATCH (CONS (EVAL (CADAR -P-)) (CDR -P-)) -D-))
  ((EQ (CAAR -P-) '/!)
   (IF (MATCH (CDR -P-) (CDR -D-))
       (SET (CADAR -P-) (CAR -D-))))))))))))))))

(STATUS 18 '/! '(LAMBDA () (LIST '/! (READ))))
(STATUS 18 '/, '(LAMBDA () (LIST '/, (READ))))

(DE PRINZ L
  (PRINT (APPEND '(AZERTYOP :) L)))

(DE SCENE () (MAPC DABA 'PRINT)
  (IF (PRESENT '(!X MAIN) DABA) (PRINT 'ET 'JE 'TIENS X)))

(DE SOLVE () (SETQ #NG (NEXTL FOCUS)))

(DE IN-DABA (X) (SETQ DABA (CONS X DABA)))
(DE OUT-DABA (X) (OUDA X DABA))
(DE OUDA (X DB) (IF (EQUAL X (CAR DB)) (RPLACB DB (CDR DB))
                    (OUDA X (CDR DB))))

(DE P-ABSURDE ()
  (PRINZ 'C/'EST 'SAUF 'VOT 'RESPECT 'MSIEU 'ABSURDE))
(DE P-DE-QUI ()
  (PRINZ 'DE 'QUI 'VOUS 'CAUSEZ 'MSIEU '/?))
(DE P-YAPAS (X)
  (PRINZ 'YA 'PAS 'DE X 'MSIEU))
(DE P-OUI-MSIEU ()
  (PRINZ 'OUI 'MSIEU 'COMPRIS 'MSIEU))

(DE FOCUS-IT (X) (SETQ FOCUS (CONS X FOCUS)))

(DE DECLARATIVE () (COND
  ((EQ #REL 'SOUS) (P-ABSURDE))
  ((OR (NULL #OBJ) (NULL #LOC)) (P-DE-QUI))
  ((DECL DABA))))

(DE DECL (DB) (COND
  ((NULL DB) (IN-DABA (LIST #OBJ 'SUR #LOC)) (FOCUS-IT #OBJ) (P-OUI-MSIEU) 
   (MAKENEWBOX #OBJ #LOC))
  ((MEMQ #OBJ (NEXTL DB)) (PRINZ #OBJ 'EXISTE 'DEJA 'MSIEU))
  (T (DECL DB))))

(DE IMPER-1 () (COND
  ((NULL #OBJ) (P-DE-QUI))
  ((PRESENT '(!X MAIN) DABA) (COND
    ((EQ X #OBJ) (PRINZ 'JELTIEN 'DEJA 'MSIEU) (FOCUS-IT #OBJ))
    (T (PRINZ 'CAISSE 'QUEJFAI 'DE X 'MSIEU '/?) (FOCUS-IT X))))
  ((PRESENT '(!X SUR ,#OBJ) DABA)
   (FREE #OBJ [#OBJ]) (IMPER-1))
  ((PRESENT '(,#OBJ SUR !X) DABA)
   (OUT-DABA (LIST #OBJ 'SUR X)) (IN-DABA (LIST #OBJ 'MAIN))
   (FOCUS-IT #OBJ) (P-OUI-MSIEU) (GOTAKEBOX #OBJ))
   (T (FOCUS-IT #OBJ) (P-YAPAS #OBJ))))

(DE WHERE-Q ()
  (IF (NULL #OBJ) (P-DE-QUI)
      (FOCUS-IT #OBJ)
      (COND
       ((PRESENT '(,#OBJ MAIN) DABA) (PRINZ 'JELTIEN 'BIEN 'MSIEU))
       ((PRESENT '(,#OBJ SUR !X) DABA)
        (IF (EQ X 'TERRE)
            (PRINZ 'PAR 'TERRE 'IL 'EST 'MSIEU)
            (PRINZ 'IL 'EST 'SUR X 'MSIEU)))
       ((PRESENT '(!X SUR ,#OBJ) DABA)  
        (PRINZ X 'EST 'SUR 'LUI 'MAIS #OBJ 'EST 'NULLE 'PART '/,
               'YA 'COMME 'CA 'DES 'OBJETS 'KISONT 'NULLE 'PART))
       (T (P-YAPAS #OBJ)))))

(DE IMPER-2 () (COND
  ((OR (NULL #OBJ) (NULL #LOC)) (P-DE-QUI))
  ((EQ #OBJ #LOC) (PRINZ 'PERSONNE 'Y 'PEU 'FAIRE 'UNE 'CHOSE 'COMME
       'CA 'MSIEU))
  ((EQ #REL 'SOUS) (P-ABSURDE))
  ((PRESENT '(,#OBJ MAIN) DABA)
   (IF (AND (NEQ #LOC 'TERRE) (PRESENT '(!X SUR ,#LOC) DABA))
       (PRINZ 'JPEUPA 'MSIEU 'YA X 'SUR #LOC)
       (OUT-DABA (LIST #OBJ 'MAIN)) (IN-DABA [#OBJ 'SUR #LOC])
       (FOCUS-IT #OBJ) (P-OUI-MSIEU) (GOPUTBOX #LOC)))
  ((PRESENT '(!X MAIN) DABA)
   (PRINZ 'CAISSE 'QUE 'JFAIS 'DE X 'MSIEU '/?) (FOCUS-IT X))
  ((PRESENT '(,#OBJ SUR !X) DABA)
   (FOCUS-IT #OBJ)
   (COND
     ((EQ X #LOC) (PRINZ 'ILYEST 'DEJA 'MSIEU))
     ((PRESENT '(!X SUR ,#OBJ) DABA) (FREE #OBJ [#LOC]) (IMPER-2))
     ((AND (NEQ #LOC 'TERRE) (PRESENT '(!X SUR ,#LOC) DABA))
      (FREE #LOC [#OBJ]) (IMPER-2))
     (T (OUT-DABA [#OBJ 'SUR X]) (IN-DABA [#OBJ 'SUR #LOC])
        (P-OUI-MSIEU) (GOTAKEBOX #OBJ) (GOPUTBOX #LOC))))
  (T (P-YAPAS #OBJ)))))))))))))))))))))


(DE FREE (X PROTECT ;; Z)
  (IF (PRESENT '(!Z SUR ,X) DABA)
      (PROGN
	(SETQ PROTECT (CONS Z (CONS X PROTECT)))
	(FREE Z PROTECT)
	(OUT-DABA [Z 'SUR X]) (GOTAKEBOX Z)
	(IN-DABA [Z 'SUR (SETQ AUX (FINDPLACEANY PROTECT))])
	(GOPUTBOX AUX)
	)))

(DE FINDPLACEANY (PROTECT ;; X Y)
  (LET ((P BOXES))
	(SETQ Y (CAAR P))
	(COND ((NULL P) 'TERRE)
	      ((OR (PRESENT '(!X SUR ,Y) DABA) (MEMQ Y PROTECT))
               (SELF (CDR P)))
	      (T Y))))